２７−２０　ユ−ザ−フォ−ムを使用した抽出
５年以上前にExcel5.0で検索マクロを作成し、「10-1項オートフィルター機能による検索｣ へ掲載しています。このマクロ自体はExcel操作の初心者も含め社内では毎日数十名以上が 利用し大変重宝がられています。ひさしぶりにソ−スを見たらGoSub...Returnステ−トメント を使用する等ExcelVBAでは一般的にほとんど使用されなくなったステ−トメントで組んで あり、多分最近VBAを始めた方は判りずらいと思う。

そこで今回、一部改善しExcel2000で作り直しました。
・このマクロは(1)〜(5)を同じ標準モジ−ルへ貼り付ければ使用できます。
・アクティブシ−トのデ−タベ−スを対象に実行します。
・「検索」ボタンは"Sub ダイアログ()"を一度実行して「解除」で出来ます。
・検索文字として、ワイルドカ−ド｢？、＊」も使用可。
・検索する条件が2個の場合、"OR"又は"AND"を使用（前後スペ−スが必要)
・数字・日付のアイテムは大・少(＜＞）の条件指定可。
・大文字・小文字を区別しないで抽出する。
(１)　検索キ−ワ−ド入力ユ−ザ−フォ−ムの表示

Sub ダイアログ()
 Application.ScreenUpdating = False
 sname = ActiveSheet.Name
 
'  オ−トフィルタ−解除
     Application.Worksheets(sname).Activate
     ActiveSheet.AutoFilterMode = False
     
     UserForm1.Show
End Sub

(２)　ユ−ザ−フォ−ムからのデ−タ取得とデ−タ検索
下図は"Sub 検出結果()"プロシ−ジャ実行前の図。

Sub 検索()
' ダイアログのデ−タ入力
      dat = UserForm1.txt1.Text
    
      If UserForm1.opt1.Value = True Then
         kom = 1: ms1$ = "項目"
      ElseIf UserForm1.opt2.Value = True Then
         kom = 2: ms1$ = "品名"
      ElseIf UserForm1.opt3.Value = True Then
         kom = 3: ms1$ = "数量"
      ElseIf UserForm1.opt5.Value = True Then
         kom = 4: ms1$ = "配膳"
      ElseIf UserForm1.opt5.Value = True Then
         kom = 5: ms1$ = "組立"
      ElseIf UserForm1.opt6.Value = True Then
         kom = 6: ms1$ = "点検"
      Else
         MsgBox "検索するアイテムを指定して下さい"
         Exit Sub
      End If
'
'データ２個検索
     op = 0: data = 0: datb = 0
    data = InStr(1, dat, " or", 1)
    datb = InStr(1, dat, " and", 1)
    If data > 1 Then
       op = 1
       dat1 = Trim(Mid(dat, 1, data - 1))
       dat2 = Trim(Mid(dat, data + 3))
    End If
    If datb > 1 Then
       op = 2
       dat1 = Trim(Mid(dat, 1, datb - 1))
       dat2 = Trim(Mid(dat, datb + 4))
    End If
    UserForm1.Hide
'
'デ−タ検索
      Application.Worksheets(sname).Activate
      Range("a1").Select
    If op = 1 Then
      Selection.AutoFilter Field:=kom, Criteria1:=dat1, _
      operator:=xlOr, criteria2:=dat2
    ElseIf op = 2 Then
      Selection.AutoFilter Field:=kom, Criteria1:=dat1, _
      operator:=xlAnd, criteria2:=dat2
    Else
      Selection.AutoFilter Field:=kom, Criteria1:=dat
    End If
'
  If ActiveSheet.Buttons.Count = 1 Then
    ActiveSheet.Buttons.Select
        nam = Selection.Name
    ActiveSheet.Buttons(nam).Select
        Selection.Delete
  End If
    
    ActiveSheet.Buttons.Add(340.5, 1.5, 31.5, 14.25).Select
        Selection.OnAction = "解除"
        Selection.Characters.Text = "解除"
    Range("A1").Select
    検出結果
End Sub

(３)　検出結果の処理
・このマクロでフイルタ−が掛かり「解除」ボタンが付く。
・下図「はい」で（4）項に進む。
・下図「いいえ」で最初の状態に戻る。
・下図「キャンセル」でフイルタ−の掛かった状態。
・「解除」ボタンをクリックで、最初状態に戻り「検索」ボタンが付く。

 

Sub 検出結果()
 Application.ScreenUpdating = True
      ms3$ = ""
      ms2$ = "を検索しました。" & Chr$(10) & _
           "この結果を｢検索結果｣シ−トへコピ−しますか？"
      ta = MsgBox("[" & ms1 & "]" & "の ｢" & dat & "｣ " & ms2$, 3, "検索結果")
 Application.ScreenUpdating = False
      If ta = 2 Then
         Exit Sub
      ElseIf ta = 7 Then       '  オ−トフィルタ−解除
        ActiveSheet.AutoFilterMode = False
        ActiveSheet.Buttons.Select
            nam = Selection.Name
        ActiveSheet.Buttons(nam).Select
            Selection.Delete
        ActiveSheet.Buttons.Add(340.5, 1.5, 31.5, 14.25).Select
            Selection.OnAction = "ダイアログ"
            Selection.Characters.Text = "検索"
            Range("A1").Select
            Exit Sub
      Else
         コピイ
      End If
End Sub

(４)　検索結果の貼り付け方法指定
・このマクロで抽出した結果を検索結果シ−トへ貼り付ける。
・下図の「はい」で新しいデ−タは、前に貼り付けた下へ追加される。
・下図の「いいえ」で新しいデ−タのみ貼り付けられる。

 

Sub コピイ()
'シ−トの有無チェック
        sck = 0
    For Each sheet_name In Worksheets
        If sheet_name.Name = ("検索結果") Then
           sck = 1
           Exit For
        End If
    Next
' シートの追加
    If sck = 0 Then
       Sheets.Add.Name = "検索結果"
    End If
      ms2$ = "前回検索の下へ追加しますか。"
      tb = MsgBox(ms2$, 4, "検索結果の表示")
If tb = 7 Then
    If sck = 1 Then
        Application.DisplayAlerts = False
            Sheets("検索結果").Delete
        Application.DisplayAlerts = True
           Sheets.Add.Name = "検索結果"
            Range("A1").Select
    End If
    cen3 = 1
Else
   Sheets("検索結果").Select
   Selection.SpecialCells(xlCellTypeLastCell).Select
   cen3 = ActiveCell.Row
End If
' セル数のチェック
   Sheets(sname).Select
   ccc = 0
   Range("a1").CurrentRegion.SpecialCells(xlCellTypeVisible).Select
   For Each sel In Selection.Areas
        ccc = ccc + sel.Rows.Count
   Next sel
   ms3 = "-----　" & ccc - 1 & "個抽出"
      
   If ccc = 1 Then
       Sheets("検索結果").Select
      ms3 = "--------- ＤＡＴＡ無し"
      最終処理
      Exit Sub
   End If
' コピ−
     Range("A1").CurrentRegion.Copy
' 貼り付け
        Sheets("検索結果").Select
         Application.Cells(cen3 + 1, 1).Select
        ActiveSheet.Paste
     '
         最終処理
       Exit Sub
End Sub

(５)　検索結果を別シ−トへ貼り付けた例
・抽出個数の貼付け。
・フィルタ−の解除。

 

Sub 最終処理()
      Range("a1").Select
          Selection.CurrentRegion.Select
          cen4 = Selection.Rows.Count
          Range("a1").Select
          Cells(cen4 + 1, 1) = "[" & ms1$ & "]" & "--- ｢" & dat & "｣ " & "の検索結果" & ms3
          Cells(cen4 + 2, 1) = "."
    
     ' オ−トフィルタ−解除
        Application.Worksheets(sname).Activate
        ActiveSheet.AutoFilterMode = False
        ActiveSheet.Buttons.Select
            nam = Selection.Name
        ActiveSheet.Buttons(nam).Select
            Selection.Delete
        ActiveSheet.Buttons.Add(340.5, 1.5, 31.5, 14.25).Select
            Selection.OnAction = "ダイアログ"
            Selection.Characters.Text = "検索"
            Range("A1").Select
        
        Application.CutCopyMode = fales
        Application.Worksheets("検索結果").Activate
        Range("A1").Select
End Sub
'

Sub 解除()
 '  オ−トフィルタ−解除
     Application.Worksheets(sname).Activate
       ActiveSheet.AutoFilterMode = False
       ActiveSheet.Buttons.Select
       nam = Selection.Name
       
       ActiveSheet.Buttons(nam).Select
        Selection.Delete
      ActiveSheet.Buttons.Add(340.5, 1.5, 31.5, 14.25).Select
    Selection.Characters.Text = "検索"
    Selection.OnAction = "ダイアログ"
    Range("A1").Select
End Sub
目次へ戻る

テレワークならECナビ Yahoo 楽天 LINEがデータ消費ゼロで月額500円〜！
無料ホームページ 無料のクレジットカード 海外格安航空券　海外旅行保険が無料！ 海外ホテル